MacWorld 1999 July/Macworld (1999-07).dmg/Shareware World/Info/For Developers/Mops 3.4.sea/Mops source/PPC source/qpClass

Text File | 1998-12-18 | 81KB | 3,087 lines

ppc?
[IF]

forward  (meth_in_mod)        \ calls a method in a module when the module
                            \  is already loaded and we know its base
                            \  addr - see zModules.

forward  register_check

\ forward ?enterHeldMod        \ If an object's class is in a module, heldMod
                            \  will be nonzero straight after we resolve the class
                            \  pointer.  Even if we eventually bind to a method that's
                            \  not in the module, it turns out we need the module's
                            \  base registers set up since we might call other methods
                            \  that are in the module, via linked objects.

\ :f ?enterHeldMod  ;f        \ need to give it an initial dummy definition
                            \  'cause it gets called before zModules is
                            \  loaded.

0    value    prev_link        \ saves prev link to current method - in
                            \  68k mode, it's in cg5 which gets
                            \  loaded first

[THEN]


PPC? not
[IF]
' pfind  -> ufind            \ in case of error - we set it to 1stFind
                            \  once we define it below
[THEN]


\ For all the class/object formats, see cg1.



    12    constant    obj_hdr_length        \ was 8 on 68k

false    value        68k_align?            \ used in implementing 68k_record, so we
                                        \  can handle 68k-format Toolbox records


PPC?
[IF]        \ We have to define all the values etc. that are defined in Class
            \  on the 68k.

    20    constant    static_ivar_offs
                            \ the offset from the start of the ivar dic
                            \  info for a static ivar, to the ivar's data.
                            \  The ivar info is 18 bytes long, then we have
                            \  to align.


    0    value    PUB/PRIV    \ -1 private, 1 public, 0 default - for ivars and methods
false    value    STATIC?        \ true if following ivars are to be static
    0    value    ^COMP_CLASS    \ addr of the class we're currently compiling
    0    value    PIVAR        \ hashed name of any public ivar we're accessing
    0    value    PIVSEL        \ hashed selector of any msg being sent to
                            \  to a public ivar

    0    value    NEWOBJECT    \ addr of object being created
    0    value    #SUP        \ number of superclasses for current class
    0    value    SUPERS_TO_SKIP

false    value    REC?        \ Are we compiling a record?
false    value    UNION?        \ Are we compiling a union in a record?
    0    value    UNIONOFFS    \ Base offset of the current union
    0    value    emb_obj_offs    \ used in inline binding - deliberately
                                \  a different name to emb_obj_offs
                                \  in qClass so we don't get confused

initID    constant    INITID


: ILFA     ( infa -- ilfa )     inline{ 4+}  ;

: ^ICLASS  ( infa -- ^class | 0 )
    8 + dup @ NIF   drop 0   ELSE   @abs ?>classInMod   THEN  ;

: IOFFS    ( infa -- ioffs )    inline{ 12 + w@}  ;
: I#ELS    ( infa -- #els )    inline{ 14 + w@}  ;
: IFFA     ( infa -- iffa )    inline{ 16 +}  ;

: ^NEXTIVAR    \ ( infa -- infa' )
    ilfa  displace  ;

[THEN]


: >OBJ        \ ( xt -- addr )  xt results from ticking an object, or the
            \  equivalent (ticking an object isn't really legal).  Returns
            \  the object's data address.  On the 68k this was just 8+,
            \  but here we have to go from the code to the data area.
    2+ @abs  ;

: OBJ>        \ ( addr -- xt | 0 )  takes an obj's base addr, and returns the
            \  xt of its dic entry, or zero if none.
    12 - dup @ IF  @abs  ELSE  drop 0  THEN  ;


ppc? not
[IF]            \ the PPC versions of these are in pnuc4

: CLASS?  ( xt -- xt b )
    dup 2- w@
    dup  $ BC1D = swap $ BC2D = or  ;    \ class_h or class_in_mod_h are OK


: CHKCLASS    \ ( xt -- xt )
    class?  ?EXIT
    .id  space  80 die  ;


: >classRP { ^obj \ ^class tmp -- ^classRP | -- 0 }

(*    Takes an object address and returns the address of the reloc pointer
    to the class (which will be somewhere in front of the object's data).
    Returns zero if the passed-in address isn't an object address.
    Needs to work for heap as well as dictionary objects.  The test is very
    unlikely (maybe 1/2**24) to indicate a non-object as being an object.
    To save time we don't do a conservative check on ^obj actually being a
    legal address (unlike ALIGNED_ADDR?), apart from checking that it is aligned,
    which is a very quick check.  This means we may crash if an aligned but
    illegal address is passed in.  The presumption is that it really is an
    object address, and that anything else is a comparatively unlikely error.
*)
    false                            \ guilty until proven innocent
    ^obj 3 and              ?EXIT    \ if not aligned, it can't be an obj addr
    ^obj -> theObj                    \ save obj addr in theObj - needed sometimes
    ^obj 4 - w@x -> tmp                \ grab ^class offset
    tmp 3 and                ?EXIT    \  which must be aligned
    tmp $ FF00 and $ FF00 =    0EXIT    \  and must be $FFxx
    ^obj 4 - ++> tmp                \ now tmp points to the reloc class ptr
    drop  tmp                        \ which is what we return
;

: classRP>class  { ^classRP -- ^class | -- 0 }
        \ Takes the address of a class reloc pointer, and returns the
        \  real class address, going into a module if necessary.
        \ Returns zero if the reloc pointer doesn't point to a class.

    ^classRP @abs  class?
    NIF  drop 0  EXIT  THEN        \ if not a class, orig addr wasn't an obj addr

\    ?>classInMod        - no modules in target compilation
;


: >CLASS  { ^obj \ ^class tmp -- ^class | -- 0 }

(*    Converts an object address to its class address, going into a module if
    necessary.  Returns zero if the passed-in address isn't an object address.
    For other comments, see >classRP.
*)

    ^obj >classRP  dup  0EXIT        \ out with zero if not a legal object
    classRP>class
;

[THEN]


: ?>CLASS   ( ^obj -- ^class )
    >class  dup NIF 81 die THEN  ;        \ If no legal class ptr, probably
                                        \ not an obj addr at all!

: ?CLASS        \ Error if not compiling a class definition.
    cstate NIF 115 die  THEN  ;


PPC? not
[IF]

(*    The following offsets refer to where a ^class points, i.e. the cfa
    of the class.  They're a bit different on the PPC.  And here in
    cg-class in 68k mode, I can't use inlines since I've already
    redefined inline{ to compile PPC stuff, and it's immediate!

    In PPC mode, I'm defining these in pnuc4, since they're needed
    by (findM) which comes there.

    MFA_offset picks one of the 8 method threads, given a selID.
    The selID is probably not very random in the low byte (since
    selectors all end in ":", so we hash it a little more then pick
    the 3 bits from the result which are already in the right position.

    Note: it took a surprising amount of trial and error to get a
    good extra hash for this particular use!
*)

: MFA_offset  ( selID ^class -- selID ^class MFA_offset )
    over
    dup 5 >> +
    $ 1C and  2 +  ;

\ 34    constant    IFA_offset    *** we can't use CONSTANT here in qClass!

: FFA    ;            \ Flags

: MFA  ( SelID ^Class -- SelID MFA )  MFA_offset  + ;

: IFA    34 +  ;            \ ivar link
: DFA    40 +  ;            \ Data len (2 bytes),
                        \  width of indexed elts (2 bytes)
: XOFFA    44 +  ;            \ offset to ivar with indexing offset for
                        \  large_obj_arrays
: SFA    46 +  ;            \ Superclass N-way pointer

\ 46    constant    classSize        \ total size of class info up to N-way


[THEN]


: into_flags  { new_flags -- }
    ?class  ^comp_class ffa dup w@  new_flags or  swap w!  ;

: CAN_BE_GPR        $ 30  into_flags  ;
: CAN_BE_FPR        $ 40  into_flags  ;
: CAN_BE_VR            $ 50  into_flags  ;

: ALIGNMENT  ( n -- )  8 << into_flags  ;        \ n is power of 2


\ for our 68k compilation, there aren't any modules.  The real versions
\  are in pnuc3.

PPC? not
[IF]

: ?>classinMod  ;
: ?unholdMod  ;

: xcan_be_gpr    can_be_gpr  ;

[THEN]


: (^DLEN)    \ ( ^obj -- ^datalen )  This is a low-level word which should
            \  normally only be used in the Mops system stuff.  Note it
            \  takes ^obj, not ^class, and it doesn't do a module check
            \  - it assumes the class is in the same segment as the object.
    ?>class dfa  ;

: (DLEN&XWID)    ( ^class -- dlen xwid )    \ Assumes ^class is the true class
        dfa dup  w@  swap  2+ w@  ;        \  address, not main dictionary address
                                        \  of exported class in module
                                        \ Only intended for internal use!

: DLEN&XWID        ( ^class -- dlen xwid )
    ?>classInMod
    (dlen&xwid)
    ?unHoldMod  ;


: DLEN    dlen&xwid  drop  ;
: XWID    dlen&xwid  nip   ;


PPC?
[IF]
: IVARLEN    inline{ dlen} ;                \ an alias for dlen
[ELSE]
: IVARLEN    dlen  ;
[THEN]

: OBJLEN    \ ( -- objlen )  Computes total data length of current object.

    ^base (^dlen)  dup w@            \ ivar len
    swap 2+ w@  ?dup
    IF            \ we're indexed
        swap  #off-align 6 +  swap    \ add len of indexed header
        idxBase 4- @ 1+  * +        \ and len of indexed elements
    THEN
;

PPC?
[IF]
: ?>MAINDIC  { ^class -- '^class }
        \ If ^class is exported from a module, we return the main dic
        \ equivalent.  If it's not exported, we return it unchanged.
        \ We need this word since for exported classes, we need to use the
        \ imported address (in the main dictionary) as the class pointer
        \ in a new object or an ivar dic entry (so that the module will be
        \ invoked properly when a method is sent to the object.

    ^class ffa 1+ c@  2 and
    IF        ^class >name n>count sfind drop
    ELSE    ^class
    THEN  ;

[THEN]


: LARGE_OBJ_ARRAY_CHECK  { ^class offs \ xoffs  -- offs xdispl-offs }

\ Following <findM> or <IVfindM>, we check if this is a large_obj_array,
\  in which case we might have to map the obj/ivar into the indexed area:

    ^class xoffa w@  -> xoffs    \ offs where remapping ends - are we before that?
    ^class searchedClass <>
    offs xoffs <  and
    IF            \ yes - remapping necessary.  Return offs to xdispl ivar
        offs  xoffs 12 +
    ELSE        \ no - normal case - just return zero
        offs 0
    THEN
;


: <findM>  { selID ^class \ xt offs  -- xt offs xdispl-offs }

(*    Factored out from clFindm and objFindm.  Finds a method's cfa given a
    selID and a class address, *which has already been converted to a module
    addr if necessary*.

    offs will be nonzero if the method turns out to belong to a superclass
    with a non-zero offset in the object - i.e. an embedded object.
    If it's a large_obj_array, and the object is in the indexed area,
    xdispl-offs will be nonzero.  This allows the caller to compile
    code to add the offset to the selected element.
*)
    ^class -> objClass                    \ used in error msgs and inline binding

    selID  ^class  MFA_offset  true  (findm)
    NIF  cr  ^class .id  108 die        \ "method not found"
    THEN
[ ppc? not ]
[if]
    4+        \ (findm) on 68k returns 68k method cfa - on PPC the
            \  equivalent is 4 bytes later - same as the xt of a
            \  colon defn.
[then]
    -> xt  -> offs
    offs -> emb_obj_offs                \ may need this in inline binding
    xt
    ^class offs  large_obj_array_check
;


: <findIV>  { selID ^class \ ^ivar offs -- ^ivar offs xdispl-offs T | -- F  }

(*    Basic routine to look for an ivar.  It's not an error if we don't find it,
    so we return a flag.
*)
    selID ^class  34 ( IFA_offset )
    false (findm)  NIF  false  EXIT  THEN

[ ppc? not ] [if] 8 - [then]    \ 68k (findm) returns ^ivar + 8
    -> ^ivar  -> offs            \ note - (findm) has returned the base
                                \  offs here - zero if not mult inherited
    ^ivar 12 + w@  ++> offs
    ^ivar
    ^class offs  large_obj_array_check
    true
;


: ClFindM  { selID ^class -- cfa offs xdispl-offs }

(*    finds a method's cfa given a selID and a class address, which hasn't
    been checked for being in a module.  The returned results are as
    described above for <findM>.
*)
    ^class ?>classInMod -> ^class
    selID ^class  <findM>
;


: ObjFindM  { selID ^obj \ ^class -- xt offs xdispl-offs
                                | -- xt offs 0 }

(* Finds a method's xt given a selID and an obj addr.  The returned
    results are as described above for <findM>.
*)
    ^obj >class  -> ^class            \ will go into a module if nec

    ^class NIF  81 die  THEN        \ "not an object"
    selID ^class  <findM>
;


: IVFindM    \ ( selID ^ivar -- xt offs xdispl-offs )
\  Looks for a method in an ivar.

\ Now we get the ivar's class - in the case of SELF, on the PPC it's
\  tricky to put the current class into the dummy ivar info for SELF,
\  but we can always tell if it's SELF from the offset.

    dup 12 + w@x -1 =
    IF                    \ it's self - class is what we're compiling
        drop ^comp_class
    ELSE
        8 + @abs        \ get addr of class from ivar info
    THEN
    clFindm  ;


(*    ivFind is called when we've parsed a selector.  It determines if the next
    word is an ivar.
    Note: if found, <findIV> returns the equivalent of the cfa of
    a method, which for ivars, is the addr of the class pointer.
*)

: ivFind  { str-addr -- ^ivar offs xdispl-offs T |  -- str-addr F }
    str-addr
    cstate  NIF  false  EXIT  THEN
    hash ^comp_class  <findIV>        \ ( ^ivar offs xdispl-offs  T  |  F )
    IF        true
    ELSE    [ ppc? ] [if] CDP [else] DP [then]  false
    THEN
;


PPC? not
[IF]            \ want to get rid of conditional compilation via  ppc_only ,
                \  but stymied by call to PFind!  The following will be
                \  duplicated in zClass.

\ TOfind looks for a temp (local) object.

: TOfind  { str-addr -- ^ivar offs T | -- str-addr F  }
    str-addr
    tmpObjs  NIF  false  EXIT  THEN
    hash
    tmpObjs <findIV>
    IF        drop        \ xdispl-offs must be zero for class Dummy
            true
    ELSE    str-addr false
    THEN
;

(*
LocFind will be called from Ufind, which is the vector that gets first
shot at recognizing a word.
It looks at all the possibilities involving local names, which are
not in the regular dictionary.  These possibilities are: named parms/locals,
local objects, and if a class is being compiled, ivars of this class.

In the latter case, we arrange for the ivar's address to
be pushed at run time simply by compiling ^base followed by an add of the
ivar's offset - our code generation will produce optimal code for this.
We then have to return the xt of some word to keep FIND happy - we don't
need to compile anything else, so we use the xt of NULL and return a 1
instead of True - this makes FIND think it's immediate.  So NULL is
executed immediately, which does precisely nothing.

The one exception to this is if the "ivar" turns out to be SELF or SUPER
- in this case we need to call the nucleus word SELF which works out
the right base address (this is what happened pre-2.5).  Here we keep
FIND happy by pushing the xt of SELF and True, so that it sees we've
found SELF.
*)

: LocFind        \ ( str-addr -- cfa T  |  -- str-addr F )
    Pfind    ?dup  ?EXIT                    \ Found a named parm/local
    TOfind
    IF                                    \ Found temp obj
        drop                            \ Don't need its dic addr
        postpone locReg  postpone literal  postpone +
        ['] null  1   EXIT
    THEN

\ Now we look for an ivar name

    cstate  NIF  false  EXIT  THEN        \ search fails if we're not compiling
                                        \  a class

    dup hash ^comp_class 34 ( IFA_offset ) false  (findM)
    IF                                    \ Found ivar
        nip nip                            \ don't need embedded obj offs or
                                        \  string addr
        4+ w@                            \ ivar offset
        dup $ FFFE >=                    \ is it SELF or SUPER (just used in
                                        \  isolation)?
        IF    drop
            " (^base) 4- dup w@x + 8 +" evaluate        \ i.e. SELF - but I can't evaluate
                                                        \  that, or we'll end up here again
                                                        \  and infinitely recurse!
        ELSE
            postpone (^base) postpone literal  postpone +
        THEN
        ['] null  1
    ELSE    false
    THEN  ;


: ILFA     ( infa -- ilfa )    4+  ;


: ^ICLASS  ( infa -- ^class | 0 )
    8 + dup @ NIF   drop 0   ELSE   @abs ?>classInMod   THEN  ;


: IOFFS    ( infa -- ioffs )    12 + w@  ;
: I#ELS    ( infa -- #els )    14 + w@  ;
: IFFA     ( infa -- iffa )    16 +  ;


: ^NEXTIVAR    \ ( infa -- infa' )
    ilfa  displace  ;

[THEN]


ppc?
[IF]

: EX-METHOD  { ^obj xt -- }

    meth_seg# 9 >
    IF                    \ method's in a module
        comp_seg#
        IF        meth_seg# comp_seg#
        ELSE    meth_seg#  mod_seg#
        THEN
        <>
        IF                \ we're changing modules
            ^obj  xt  meth_seg# segTable_entry 4+ @  meth_seg#  (meth_in_mod)
            EXIT
        THEN
    THEN

    ^obj -> rY  xt execute
;


(*    We use a cache to speed up late binding.  A hit means we get there in
    150 instructions or so instead of 500, including the EXECUTE stuff.

    LB_cache entry format:
    4 bytes        class reloc ptr
    4 bytes        selID
    4 bytes        method xt
    2 bytes        offs
    2 bytes        xdispl_offs
    2 bytes        meth_seg# for target method
*)

    variable    LB_cache        512 reservex


0        value    #hits
0        value    ^entry
true    value    use_LB_cache?        \ for debugging
0        value    cache_dbgr            \ ditto


: find_in_cache?  { classRP selID \ offs addr -- true | -- false }

    classRP selID xor  $ 1E0 and            \ 16-way hash, 32-byte blocks
    LB_cache +  -> addr
    use_LB_cache? nif false exit then

    addr @  classRP =
    IF    addr 4+ @ selID =
        IF            \ found!
            1 ++> #hits
            addr 8 + @                    \ meth xt
            addr 12 + w@                \ offs
            addr 14 + w@                \ xdispl_offs
            addr 16 + w@  -> meth_seg#

            true  EXIT
        THEN
    THEN

    addr -> ^entry
    false
;


: SEND  { ^obj selID \ classRP svMC svMD addr -- }
                \ Executes a method given the object addr and the hashed
                \  selector.  Used in late binding.
                \  Can also be used if you have a dynamically determined
                \  method ID.

    ^obj >classRP @ -> classRP
    classRP selID  find_in_cache?
    NIF
        ^entry -> addr

        selID ^obj  objFindM    \ ( xt offs xdispl-offs | xt offs 0 )

        classRP        addr !
        selID        addr 4+ !
        meth_seg#    addr 16 + w!

        dup            addr 14 + w!
        over        addr 12 + w!
        2 pick        addr 8 + !
    THEN

    ?dup
    IF        ^obj + dup @ + +
    ELSE    ^obj +
    THEN
\ ( xt ^obj' )
    swap  ex-method
;

[THEN]


PPC? not
[IF]

\                        ========================
\                                BINDING
\                        ========================


(*    Note: I think our obj_ind value might become obsolete on the PPC, since
    we don't now use an indirect count in an OD, but just do repeated fetches
    to different registers till we come to the data we want.
    On the 68k, as far as I can tell, the only time obj_ind wasn't zero was
    when we did an early bind to an addr on the stack, or to an objPtr (which
    used the same code).  This was also the reason we kept two offsets
    - obj_displ and obj_local_displ.  Obj_displ applied before any indirection
    steps, and obj_local_displ after.  I think on the PPC these complexities
    might be able to go away.
*)


: (OBJ)        \ Called from within an inline method.  Passes the object's
            \  base and displacement to Handlers to generate the correct
            \  address.  Optimization will then apply.

    obj_base obj_displ
    obj_ind  genaddr
    obj_local_displ  postpone literal  postpone +  ;


: (IX)

    (*    Called from within an inline method.  Compiles code to generate
        the indexed address.
        ^comp_class has been set by inl_bind to the class of the obj
        we're binding to.  One tricky point is that to access the indexed
        area, we have to use the dlen value in this class, not the class
        of the method we're calling (which may be a superclass).  But
        the obj_local_displ has already had the embedded object offset
        added in (if any).  We have to ignore this, since we're using
        the object's class, not the method's.  When the method was found,
        the value emb_obj_offs was set to this offset, so we subtract
        it here.
    *)

    ^comp_class dlen&xwid  swap
    self?
    IF  drop  -1  ELSE  #off-align  6 +  THEN
    obj_base obj_displ obj_local_displ
    emb_obj_offs -
    obj_ind  ^comp_class ffa w@
    genxaddr  ;


: ^BASE
    compinline?
    IF        (obj)
    ELSE    postpone (^base)
    THEN  ;            immediate


: ^ELEM
    compinline?
    IF        (ix)
    ELSE    " (^elem)"  evaluate            \ need PPC version
    THEN  ;            immediate


: OBJ    postpone ^base  ;    immediate        \ for backward compatibility
: IX    postpone ^elem  ;    immediate        \ ditto


local  EARLY_BIND  { oCfa oBase oDispl oLDispl oind slf? -- }


: INL_BIND    \ ( -- b )
    ^comp_class  cstate  self?                    \ Save over upcoming evaluate
    slf? NIF  objClass -> ^comp_class  THEN        \ Set ^comp_class and cstate
    true -> cstate                                \  so ivars are accessible
    slf? -> self?
    oCfa  inline_h
    -> self?  -> cstate  -> ^comp_class            \ Restore
;


: NORM_BIND
    oCfa  (obj)  call_h  ;        \ call_h will see by the handler code
                                \  that this is a method, and do the
                                \  right things


:loc  EARLY_BIND        \ { oCfa oBase oDispl oLDispl oind slf? -- }
    obj_base  obj_displ  obj_local_displ  obj_ind        \ Save
    oBase    -> obj_base            oDispl    -> obj_displ
    OLdispl    -> obj_local_displ    oind    -> obj_ind

    oCfa 2- w@  $ BD40 =
    IF      inl_bind
    ELSE    norm_bind
    THEN

    -> obj_ind  -> obj_local_displ
    -> obj_displ  -> obj_base            \ Restore
;loc


: BIND_TO_OBJ  { cfa ^obj offs -- }
    cfa
    -1                    \ -1 as "base" signals handlers to generate
    ^obj                \  a normal dic addr.  We still carry the
                        \  offs here since if we need to access the
                        \  indexed area, we want the original obj addr,
                        \  not some embedded object.
    offs  0  false  early_bind  ;

: BIND_TO_STK    ( xt -- )
    hStkObj  0  0  false  early_bind  ;

: BIND_TO_IVAR  { cfa offs -- }
    cfa  obj_base  obj_displ
    obj_local_displ offs +
    obj_ind  false  early_bind  ;

: BIND_TO_TMPOBJ  { cfa offs -- }
    cfa
    4        \ locReg = D4 - %%% this will HAVE to change!!!
    offs
    0 0 false  early_bind  ;

: BIND_TO_SELF  { cfa offs -- }
    cfa  obj_base  obj_displ  offs  obj_ind  true  early_bind  ;


[THEN]



\                    ===========================
\                     INITIALIZING NEW OBJECTS
\                    ===========================


PPC?
[IF]

\ forward    INIT_IN_MOD            \ in zModules

: INIT_OBJ  { ^class ^obj \ xt offs -- }

(*    Performs CLASSINIT: method on object.

    Note, and this is important, we deliberately don't
    check if the offset would put us into the indexed area of a large_obj_array.
    This is because we don't want to send CLASSINIT: individually to each of the
    indexed elements, but instead we just send it to the base element.  Then,
    CLASSINIT: in the large_obj_array class copies this to the indexed elements.

    In fact, we exploit this behaviour in setting up the code generator -
    GPRs etc. are initialized via deep_classinit:, which calls init_obj here.
    If we'd just done SEND, we would have tried to go into the indexed area,
    and this would fail since the structure isn't set up yet!!

    So this is why we don't just call SEND here - we have to bypass the normal
    method lookup process.
*)

\    heldMod IF  ^class ^obj init_in_mod  EXIT  THEN
\                                \ if it's in a module, zModules will handle

    initID  ^class  MFA_offset  true  (findm)
    drop                        \ is guaranteed to find CLASSINIT: method
    -> xt  -> offs
    offs ++> ^obj                \ modify obj addr by offs (needed in case
                                \  method is defined in any superclass
                                \  but the first)
    ^obj  xt  ex-method            \ execute classinit:
;

[ELSE]

\ For the target compilation, we can't send CLASSINIT: since we're still
\  running on the 68k.  So INIT_OBJ is just a dummy.  We arrange things
\  so that this doesn't matter for the stuff we're target compiling.

: INIT_OBJ   ( theClass theObj -- )
    2drop  ;


[THEN]


: MAKE_HDRS        ( #els ) { ^class ^obj \ len wid ^xarea -- }
    \ assumes ^class is the true class address, not
    \ the main dictionary address of an exported class
    \ if theClass is not indexed, there should be no #els on the stack

        0 -> ^xarea
        ^class  (dlen&xwid)  -> wid  -> len

    \ first the xdesc (indexed area header), if indexed object

        wid
        IF
            len #off-align -> len
            ^obj len +                    \ xdesc address: after ivars
            dup 6 +  -> ^xarea            \ indexed hdr will be 6 bytes - save
                                        \  indexed area addr

    ( #els ^xdesc )    wid over w!            \ two bytes: indexed width
    ( #els ^xdesc )    swap 1- swap 2+ !    \ four bytes: limit ( #els-1)


                len 8 +                \ self-rel offset from class ptr to indexed
                                    \  area to be put in obj header
        ELSE    2                    \ standard offset if not indexed

        THEN

    \ now the obj header itself.  Note we leave the back ptr to the dic entry
    \  alone, since it's been set already (or needs to remain zero, as the case
    \  may be).

        ( offs )    ^obj 2- w!            \ 2 bytes: offset to indexed area
                                        \  calculated above
        ^class ?>maindic                \ don't store module addr of class!
        false -> relocChk?                \ obj address could be in the heap!
    ( ^comp_class )    ^obj 8 - reloc!        \ 4 bytes: relocatable class pointer
        true -> relocChk?
        -4 ^obj 4- w!                    \ 2 bytes: offset to class pointer --
                                        \  always -4 for non-embedded object
;

0 value bugtest


forward IVSETUP

: NW_IVSETUP  { ^nway baseOffs EOoffs \ initEOoffs supClass supOffs adr -- }

(*    Sets up the groups of ivars for each superclass of the current object/ivar
    being processed. One group for each super of a multiply inherited object.
    Each group we call an "embedded object", which sort of describes what it is.
    On entry ^nway points to the first superclass pointer in the n-way defining
    the multiple inheritance. We repeat the procedure for each superclass until
    the end marker (zero) is encountered. If the superclass is the pseudoclass
    Meta we don't do anything since it does not have any ivars.

    baseOffs is the position of the current object/ivar's data space relative
    to newObject, the current top-level object being created.
    EOoffs is the offset from newObj at which the current embedded object
    starts. When an embedded object starts at a non-zero EOoffs, we put in
    front of it a 2-byte offset to the class pointer. Note that if the
    multiply inherited object is an ivar, there may not be a class pointer!
    This doesn't matter, since it's better for multiply inherited
    objects to always have the same format, wherever they are, and any attempt
    to use the class pointer offset to get the (nonexistent) class pointer
    will most probably be caught by our checks.
*)

\ we send classinit: separately to each superclass.

    EOoffs -> initEOoffs
    BEGIN
        ^nway @abs ?>classInMod  -> supClass    \ may hold a mod
        supClass  c@ $ 80 and        \ is it META (which we don't call
                                    \  ivSetup on, to end the recursion)?
        NIF
            baseOffs EOoffs +
            initEOoffs -                \ Start of dataspace of this
            -> supOffs                    \  superclass
            supClass ifa displace            \ infa of first ivar of supClass
            supOffs  EOoffs  ivSetup
            supClass  newObject supOffs +  init_obj
        THEN
        ?unholdMod                        \ now finished with the mod
        1cell ++> ^nway
        ^nway @
    WHILE        \ another class coming up - first store 2-byte ^class offset
                \  and 2-byte indexed area offset.  We have to 4-byte align
                \  first.

        supClass dfa w@                    \ dlen of supClass. Faster than using DLEN
        #align4 ++> EOoffs                \ align - offsets will go here
        EOoffs negate 8 -                \ ^class offset for store
        EOoffs initEOoffs -                \ offset not already included in baseOffs
        baseOffs + newObject +  -> adr    \ final addr for where offsets to be stored
        adr w!

        newObject baseOffs +
        2- w@ 2 <>            \ is object indexed?
        IF
            newObject baseOffs + 2- wdisplace  adr 2+ wdispl!
                                        \ yes - store xarea offs
        ELSE
            2  adr 2+ w!                \ no - store 2
        THEN
        4 ++> EOoffs                    \ update EOoffs for next embedded obj
    REPEAT  ;


:f IVSETUP        { infa baseOffs EOoffs \ ivOffs ivClass -- }

(*    Recursively traverses the tree of nested ivar definitions in a class,
    building headers and indexed area headers where necessary and applying
    the CLASSINIT: method to each ivar.
    On entry infa is the nfa of the first ivar in the ivar dictionary of the
    object/ivar whose (sub)ivars we are to set up. The dictionary chain is
    followed to the end, the last link pointing to the Nway superclass pointer.
    baseOffs is the position of the current object/ivar's data space relative
    to newObject, the current top-level object being created.
    EOoffs is non-zero if the ivar whose subivars we are to set up is part
    of an "embedded object", ie. is inherited from a superclass, and this
    superclass is not the first super of the current top-level object.
    This is given on unmodified in any recursive call and used only by
    NW_IVSETUP to calculate the offset to the class pointer.
    When this word is called, if the object/ivar's class is in a module,
    the module will be held. In some circumstances the caller still needs it.
    The recursive call might require another module to be held, so we have to
    save and restore any module held on entry.
*)
    heldMod                \ If class is in module it must not get unheld
                        \  while processing so keep address on the stack
    0 -> heldMod        \  and clear heldMod so it cannot be unheld

    BEGIN
        infa @ 0>    \ A selector is always negative, so a
                    \  positive value means the N-way superclass
                    \  pointer area ( superclass adresses ),
                    \  the endpoint of the ivar dictionary chain

    NWHILE    \ build this ivar in object

        infa iffa w@ 2 and            \ Static ivar? -> not in obj (bit 1)
        NIF    infa ioffs                \ Offset of ivar in owning object
            baseoffs +   -> ivOffs    \ Position relative to newObject
            infa ^iclass -> ivClass    \ May cause another module to be held
            infa iffa w@ 1 and        \ Does it want headers? -> flag bit 0
            IF    infa i#els dup NIF drop THEN
                ivClass
                newObject ivOffs +     \ address where headers must be made
                make_hdrs
            THEN
\            ?Rdepth                    \ Check on recursion depth
            ivClass ifa displace    \ Infa of first subivar in
                                    \  chain of the currently
                                    \  processed ivar object
            ivOffs                    \ New base offset of subivar
            0
            ivSetup
            ?unholdMod
            ivClass  newObject ivOffs +  init_obj
        THEN
        infa ^nextivar -> infa
    REPEAT

    infa baseOffs EOoffs  NW_ivSetup        \ set up superclasses
    ( Heldmod )  -> HeldMod
;f


\                    =================================
\                            OBJECT BUILDING
\                    =================================


\ HASHED-HDR lays down the dic header for an ivar or method.
\ The format is:
\
\ 4 bytes        hash
\ 4 bytes        link (self-relative addr of prev entry)
\
\ This entry has to become the first on the chain, so we pass in the
\ addr of the chain header.

: HASHED-HDR        \ ( chain-hdr hash-val -- )
    code,                    \ comma in hash value
    dup -> prev_link        \ save this in case a method gets moved
    dup displace            \ get abs addr of prev entry
    displCode,                \ comma it in as self-relative addr
    CDP 8 -  swap  displ!    \ update chain header
;


forward    DIC-OBJ

PPC?
[if]
: class_align  ( n ^class -- n' )
    ffa w@ 8 >> $ F and ?dup 0EXIT
    #align_2**n
;
[then]


: IVDEF  ( #els ) { iclass \ #els wid siz clOffs flags ^ccf -- }
        \ Compiles an ivar dictionary entry.  If indexed, must have
        \ < 64K elements.  iclass is the ivar's class.  The class of
        \ which this is an ivar, is pointed to by ^comp_class .


    pub/priv 1 =  4 and -> flags    \ initial flags - set bit 2 if we're public
[ ppc? ]
[if]
    iclass flags  register_check  -> flags
                                    \ update flags appropriately if this is a temp
                                    \  object in a register
    ^comp_class    ffa dup -> ^ccf
                    w@ $ F00 and
    iclass        ffa w@ $ F00 and  max
    ^ccf w@ $ F0FF and or  ^ccf w!

[then]
    Mword
    ivFind  IF 117 die  THEN        \ same name as another ivar
    drop                            \ drop string addr
    iclass xwid  -> wid                \ indexed width of ivar class
    iclass dlen  -> siz                \ non-indexed size of this ivar

\ The initial offset is the current dlen of the class.

    ^comp_class dfa w@  -> clOffs

    ^comp_class  ifa
[ ppc? ]
[if]  CDP  [else]  DP  [then]
    hash  hashed-hdr                \ dic header for ivar

    iclass ?>mainDic  relocCode,    \ class addr (reloc)

\ Now we need to comma in the 2-byte offset to the ivar within
\ the class.  First we need to make some adjustments...

    iclass ffa 1+ c@  4 and        \ general?
    dup
    IF union? IF 190 die THEN
    THEN                \ (can't have a general object in a union)
    rec? not or            \ or not in a record?
    wid or                \ or indexed?
    IF                    \ Yes - in this case there'll be a 12-byte object
                        \  header which must be 4-byte aligned no matter
                        \  what, since the header has 4-byte fields.
        clOffs #align4 -> clOffs    \  align
        obj_hdr_length ++> clOffs    \  obj's data will start 12 bytes later
                                    \  than otherwise
        1 or> flags                    \ and we'll mark this in the ivar flags
                                    \  so make_hdrs will do the right thing.

    ELSE                \ No obj header.  Alignment depends on the ivar size.
                        \ Note that if the ivar class is multiply inherited
                        \   with >1 superclass of non-zero length, the ivar
                        \  size will always be >1.
        clOffs
        68k_align?
        IF    siz 1 > IF  #align2  THEN
        ELSE
            siz 2 >
            IF  #align4
            ELSE
                siz 1 > IF  #align2  THEN
            THEN
        THEN
        -> clOffs
    THEN

\ but finally, if the class is asking for special alignment, we do that!

[ ppc? ]
[if]
    clOffs iclass  class_align  -> clOffs
[then]

    clOffs  codeW,

    wid
    IF                \ Indexed. Stack has #els.  We calculate the indexed
                    \ length of this ivar and increment clOffs.  We need
                    \ to off-align the non-indexed length, since the xdesc
                    \ is 6 bytes long with a 2-byte/4-byte layout.
        -> #els
        siz #off-align  -> siz        \ must off-align the non-indexed size, since
                                    \  the indexed hdr is 6 bytes long
        #els codeW,                    \ Add #els to ivar dic entry
        #els wid *                    \ Get indexed length
        6 +                            \ Add 6 for xdesc length    %%%%
        ++> clOffs                    \ Add to clOffs
    ELSE            \ Not indexed.
        0 codeW,
    THEN
    static?
    IF    2 or> flags
    ELSE
        siz ++> clOffs                \ Bump clOffs by non-indexed size of ivar
    THEN

    flags codeW,
    0 codeW,                        \ dummy for alignment

(* Now we'll update the class dLen field by whatever we're allocating for this
  ivar - it will then be the offset to the next ivar.  clOffs has the offset
  so far.  In the normal case, this is what goes in dLen.  If we're in
  a union, we MAX it with whatever's already in dLen.  This will leave dLen
  with the longest union element we've reached so far, which will be the final
  value in case we hit the end of the union.
  And if this ivar is static, it will live right where we are in the data
  area, and not in objects of the class, so in this case we leave dLen alone.
  We also do this if the "ivar" is really a temp object, and going into
  a register.
*)
    union?
    IF
        unionOffs  clOffs  max  -> unionOffs
    ELSE
        flags 8 >> $ F and      \ register?
        static? or                \ or static?
        NIF                        \ neither, so update dLen.
            clOffs  ^comp_class dfa w!
        THEN
    THEN

(* Now we'll check if this ivar is to be static - if so, we'll instantiate
   it right now.  We put a reloc pointer in the code area, pointing to
   the ivar's data in the data area.  We leave the back pointer field in
   the ivar header zero, since there isn't a readable name in the code
   area.
*)
    static?  0EXIT
                        \ in data area:
    align4  obj_hdr_length reserve        \ align and reserve room for obj header
                        \ in code area:
    CDP
    0  code,
    DP swap reloc!            \ store reloc pointer to obj data in data area

    wid IF  #els  THEN
    iclass  dic-obj
;


: CL>LEN ( #els ) { ^class \ wid len -- ( #els ) len2 }
                \ Gets data length of object given #els and class.
    ^class dlen&xwid  -> wid  -> len
    wid
    IF    ( #els )  dup 32766 >
        IF  ^class ffa 1+ c@ 1 and  NIF 185 die  THEN
        THEN
         dup  wid *  6 +  len +
    ELSE    len
    THEN
;


: MAKE_OBJ        ( #els ) { ^class ^obj \ svHeldMod -- }

    ^class ?>classinMod -> ^class        \ Need real class address,
                                        \  not main dic equivalent
    heldMod -> svHeldMod                \ If class is in module it must
                                        \  not get unheld while processing
                                        \  so keep the address and clear
    0 -> heldMod                        \  heldMod so it cannot be unheld
  ( #els ) ^class ^obj make_hdrs        \ Actually #els is optional element
                                        \  on the stack

    ^obj -> newObject                    \ base address used by ivSetup
    ^class ifa displace  0 0 ivSetup
    svHeldMod -> heldMod                \ held module (if any) no longer needed
    ^class ^obj init_obj                \ do a latebound CLASSINIT:
                                        \  on the object
    ?unholdMod
;



: OBJ_HDR        \ creates a header for an object in the dictionary.
                        \ in data area:
    align4  DP  obj_hdr_length reserve        \ align and reserve room for obj header

                        \ in code area:
                            \ ppc (create) not defined on 68k yet, so
                            \  we fake it:
    ppc_header
    $ BC0B  codeW,            \ handler code for objects.  We're now at
                            \  the cfa, and orig DP on stack.
    CDP swap reloc!            \ store "back pointer" at start of obj header
    0 codeW,                \ align
    CDP  0 code,
    DP swap reloc!            \ store reloc pointer to obj data in data area
;


:f DIC-OBJ  ( #els ) { theClass \ ^obj svDP xx -- }
                \ Builds an object in the dictionary.

    DP -> ^obj                        \ Where obj data will start
    theClass  cl>len  #align4        \ Required length for obj's data
\    dup room >  IF 999 die THEN        \ "Not enough room"
      reserve                            \ Allocate space for object
    theClass  ^obj  make_obj        \ Set up the object
    align4
;f


(*    The next word builds an object.  On the 68k it's called PPC_OBJ, and
    is called from PPC_interpret (in cg6) when it sees the class
    handler code BC1D.
    On the PPC it's called CREATE_OBJ.  When we dispatch on the class
    handler code, we go to CLASS_H, which compiles a push of the xt of
    the class and then a call to here.  This will normally be done in
    interpret mode, which means it will be compiled into the execution
    buffer and executed straight away.  But a class name could be
    compiled into a definition and that should work as well.
*)

PPC?
[IF]

: create_obj    \ ( (#els) ^class -- )

[ELSE]

:f ppc_obj        \ ( (#els) ^class -- )

[THEN]
    cstate    IF                        \ compiling a class
                ivDef                \ Build an ivar
            ELSE
            [ ppc? ] [if]
                DP obj_hdr_length +  over  class_align
                obj_hdr_length -  -> DP
            [then]
                obj_hdr                \ Create object header - returns
                                    \  its data address when called
                dic-obj
            THEN
[ PPC? ]
[IF]  ;  [ELSE]  ;f  [THEN]


PPC?
[IF]
forward    call_h        \ the ppc defns of these aren't loaded yet
forward lit_addr


: CLASS_H  { xt \ xx -- }
    CDP -> xx
    xt lit_addr            \ compile a push of the xt
    ['] create_obj  call_h
;


[THEN]

: HASH,        \ Compiles hashed word for name at CDP
    code_align        \ must be aligned
    bl word  hash code,  ;


PPC? not
[IF]

\ Note: in PPC mode, this code is in zClass and is loaded straight on
\  the PPC, not target compiled (which gets horrendously complicated!).


\                    ============================
\                            :CLASS  etc.
\                    ============================

(*
Here we set up some quantities so that we can send messages to SELF
or SUPER.  These are treated syntactically as ivars, so to implement
them we actually set up dummy ivars SELF and SUPER.

When we're processing a :CLASS definition, we plug the appropriate
addresses into these ivars.  ^SELF is a word defined to return the
addr of the dummy ivar SELF, so we can do the plugging.
In the case of SUPER, there may be several superclasses, so we have
to go through a class descriptor, since that's the only place we look
for an n-way (a set of addresses).  So we set the "class" of SUPER
to a dummy class SUPCL, which has no ivars or methods (so the search
will pass right on by), and plug the superclass pointer of SUPCL to
point to the current n-way for the superclasses of the class we're
defining.
*)


\ META is the super class of Object - top of all inheritance

(*
Note that SUPCL, META etc. can't be set up before CROSS, since they have
to be in the PPC image.  But to set them up we have to have access to
68k definitions.  So here with PPC? false, we define a defn that we
can execute after CROSS, which sets everything up before we try to compile
any classes.  We just call  define_meta  and it sets everything up.
*)


: define_meta  { \ ^ilink ^supcl -- }
    " META"    ppc_sHdr
    $ BC1D8000 code,        \ handler code, flags ($8000 = META)
    32 code_reserve            \ methods links - no methods

    CDP -> ^ilink
    0 code,                    \ ivar link - set to SUPER below
    0 code,                    \ dummy, data len
    0 code,                    \ indexed width, xdispl offs
    0 code,                    \ super pointer

\ Now we set up the SELF and SUPER pseudo-ivars.  We set them up exactly
\ as if they'd been declared as regular ivars in META.  But note we don't
\ set up any fields past the "offset" field, since they're irrelevant.

    " SUPCL"    ppc_sHdr
    $ BC1D0000 code,
    CDP 2- -> ^supcl
    32 code_reserve            \ methods links - no methods yet
    0 code,                    \ ivar link
    0 code,                    \ padding, dlen
    0 code,                    \ xwid, xdispl-offs

\ note: at superRef below, we need the addr of SUPER, so we tick SUPCL and
\  add the offset to SUPER which is (currently) 46 bytes.  So be careful
\  if moving anything!

    CDP                        \ ready for SELF link below
    " SUPER" pad place
    pad hash  code,
    0 code,                    \ empty link
    ^supcl  relocCode,        \ ^class is dummy supCl (reloc addr reqd)
    $ FFFE  codeW,            \ "offset" FFFE means SUPER
    0 codeW,                \ alignment

    CDP
    " SELF" pad place
    pad hash  code,
    swap  displCode,        \ link (to SUPER)
    0 code,                    \ ^class (gets patched at :CLASS time)
    $ FFFF  codeW,            \ "offset" FFFF means SELF
    0 codeW,                \ alignment

    dup    ['] (^self)    displ!    \ ^SELF will now return addr of SELF ivar
    ^ilink            displ!    \ META now has just 2 ivars - SELF and SUPER
\    " ' meta  metaAddr reloc!" evaluate
;


: :CLASS
    ?exec  ppc_header  $ BC1D codeW,
    CDP -> ^comp_class
    0 -> pub/priv  0 -> #1st  0 -> #last
    false -> rec?  false -> union?  false -> static?
    307
;        immediate


: MERGE_INFO  { ^sup ivlen \ ^wid wid prevWid -- dlen }
    ^sup dlen&xwid  -> wid        \ indexed width of this superclass
    ^sup ffa 1+ c@ 5 and        \ Merge "general" and "indexed" flags with
    ^comp_class ffa 1+  cset            \  what we have already
    wid  0EXIT                    \ If this superclass not indexed, we're done

\ This class is indexed - we need to check if prev classes were indexed
\  and make sure the widths are compatible.

    ^comp_class dfa 2+  -> ^wid        \ Addr of wid field in class we're building
    ^wid w@  -> prevWid            \ Get previous width
    wid 32760 u>                \ "indexed width" of 32766/7 really means
    IF                            \  obj_array.
        prevWid                    \ In this case if we already have a width,
        IF        prevWid -> wid    \  we use that,
        ELSE    wid
                ivlen  -> wid    \ otherwise current ivar len becomes the width.

            ( old wid ) 32766 =
                IF        \ large_obj_array - mark boundary between ivars
                        \  we are/aren't mapping to the indexed area
                    ivlen #align4  ^comp_class xoffa w!
                    wid #align4 4+  -> wid    \ and allow for ^class offset
                                            \  and indexed area offset
                                            \  before each element
                THEN
        THEN
    THEN
    prevWid
    NIF     wid  ^wid w!        \ If no prev width, set width & we're done
    ELSE    prevWid wid <>  ?error 88        \ "Incompatible indexed widths"
    THEN
;


local    (SUP)   { \ ^supcl ivlen ^nway ^sup ^newClass thisLen -- }

: NEXT_SUPER    ( cfa -- )
    chkClass  -> ^sup
    ^sup relocCode,                    \ Add ^class to n-way
    ^sup ivlen merge_info   -> thisLen
    #sup IF                            \ If this is a subsequent class,
        ivlen #align4  4+  -> ivlen    \  align and allow for ^class offset and
                                    \  2 extra bytes padding
    THEN
    thisLen ++> ivlen                \ And add ivar length of new class
    1 ++> #sup  ;


: SUPERS_LOOP
    BEGIN                        \ Loop over superclasses:
        '                        \ cfa of next item on list
        }or)? IF  drop  EXIT  THEN
        ( cfa )  next_super            \ handle next superclass
        1super?  ?EXIT                \ Yerk has only one superclass
    AGAIN  ;


:loc  (SUP)
    307 ?pairs                        \ Make sure we're in the right place
    CDP -> ^newClass
    46 ( classSize )  code_reserve            \ Space for class record
    CDP -> ^nway                    \ n-way for superclasses will
    0 -> ivlen  0 -> #sup            \  start here
    ^newClass 2+ 32 bounds
    DO  ^nway  i displ!  4 +LOOP    \ point methods links to nway
    ^nway ^newClass IFA  displ!        \ and ivars link
    false -> relocChk?
    supers_loop                        \ Loop over superclasses
    0 code,                            \ Terminate n-way
    " SUPCL" sFind drop -> ^supcl
    ^supcl 2+ 32 bounds
    DO  ^nway  i displ!  4 +LOOP    \ we point the method and ivar links
    ^nway                            \  in supcl to the n-way
    ^supcl IFA  displ!

    ^comp_class xoffa w@
    " SUPCL" sFind drop xoffa w!    \ and set xoffs in supCl

    ivlen ^comp_class dfa w!        \ Set total ivar length
    ^comp_class  ^self 8 +  reloc!    \ Store ^class in SELF
    true -> relocChk?
    postpone ]c                        \ In a class definition
    308
;loc


: SUPER{        false -> 1super?   (sup)  ;        immediate

\ : SUPER(        postpone super{  ;                immediate

\ : <SUPER    true -> 1super?  (sup)    ;            immediate
            \ For compatibility with Yerk -- only looks for 1 superclass


: (;CL)
    postpone [  postpone c[
    0 ^self 8 + !  ;


: ;CLASS
    (;cl)  308 ?defn  ;            immediate



: M_HEADER  { selID -- }    \ Builds a method header and entry sequence.
                            \ Note: also called from the assembler.
    selID ^comp_class MFA  selID  hashed-hdr    \ Build header
    drop                            \ drop extra selID (needed by MFA)
    pub/priv -1 =  1 and  codeW,    \ public/private flag (default is public)
    0 codeW,                        \ padding for alignment
    $ BE400000 code,                \ "handler code" for PPC methods,
                                    \  and initial flag bytes
    CDP -> thisM                    \ Remember method cfa
;

\    0 codeW,                        \ space for parm flags (or do it in Mentry?)
\    Mentry  ;                        \ Compile the entry sequence



: :M { \ selID -- }            \ Starts compiling a method.
    true -> method?
    ?class
    rec? ?error 191                    \ unmatched '{' in ivar list
    0 -> superM
    getSelect -> selID
    10 -> cstate                    \ Means we've read :m, no call_1st yet

(*    selID ^class 2 (findm)            \ is method already defined?
    IF
        -> superM
        warnings?
        IF    cr  0 -> out
            here count type type# 182             \ "Method redefined"
        THEN
        heldMod
        NIF  superM ^class > ?error 183  THEN    \ - but if in same class, error
        drop
    THEN
*)
    get1st&last  ?unHoldMod
    CDP -> const_data_start
    selID m_header                    \ Build method header
    #1st #last +
    IF  $ 80  thisM 7 - cset  THEN    \ set call1st/callLast flag
    $ 74 -> obj_base                \ $60 + $14.   $60 says it's a PPC reg
                                    \  number, and gpr20 is obj base reg
    0 -> obj_displ                    \ For any inline method calls
    false ppc_entry                    \ Start to compile the method

\ we don't want to export any leaf methods, since we don't know anything
\  about them at the point of call.  This might be a bit of overkill, but
\  we'll fix the problem by not having any leaf methods in modules!  I don't
\  think it's worth trying anything cleverer.

[ ppc? ] [if]
    compmod IF  false -> leaf?  THEN
[then]

    drop 305                        \ change security marker to say method
    doCall1st  ;    immediate        \ Compile any Call1st calls first


: ;M
    curr-def 2-  (;)
    #last  IF  true -> method?  doCallLast  defnEnd  false -> method?  THEN
    0 -> #1st  0 -> #last
    305 ?defn  ;        immediate


\    ============== Local sections for methods ==============

\ These function just like regular local sections.  The implementation
\ is nearly the same.


: MLOCAL        \ Starts a local section for methods
    local?  ?error 93  1 -> local?        \ We change it to the normal -1
                                        \ as soon as "{" is read.
    postpone :m  drop
    postpone [
    CDP -> mloc_addr
    $ 48000000  code,        \ uncond branch to be resolved by :mloc
    private  ;


: :MLOC
    public  ?loc  getSelect drop
    CDP -> const_data_start
    $ BE030000  code,                \ marks this as the :mloc position
                                    \  (just for disassembly)
    false -> local?                    \ so entry sequence gets compiled
    false ppc_entry                    \ handle ppc proc entry
    drop 309                        \ security marker for :mloc
    curr-def
      mloc_addr -> curr-def
      PLentry
    -> curr-def
    frameSize IF  initTemps  THEN
;        immediate


: ;MLOC
    309 ?defn
    false -> leaf?            \ let's just reduce the bug possibilities!
    mloc_addr 2-  (;)
    #last  IF  true -> method?  doCallLast  defnEnd  false -> method?  THEN
    0 -> #1st  0 -> #last
    curr-def mloc_addr -    \ finally we resolve the forward branch
    mloc_addr +!            \   from LOCAL
;            immediate


\    ================   INDEXED, GENERAL etc.   =================

\ These are words which can appear in a class declaration, in the
\ position

\  :class someClass super{ someSuper }   general

\ They add attributes to the class.


: INDEXED        \ ( width -- )  Sets a class and its subclasses to indexed
    ?class  ^comp_class dfa 2+  w!  ;

: LARGE  ;        \ in effect, this always applies on the PPC


: GENERAL

(* Sets the "general" option on a class, which will force an ivar of that class
   to be a general object with a class pointer (so it can be late-bound to) even
   if it's within a record.  Normally you should just not put such ivars in a
   record, but using GENERAL gives a bit of extra security, for classes for which
   you know that they will definitely be late-bound to.  (An attempt to late-bind
   to an ivar without a class pointer will give the "not an object" error at run
   time, which isn't easy to track down.)
   Note that indexed classes are always general anyway.  Also if there's a message
   sent to [self] somewhere in one of the methods, we know that the class *must*
   be general, so in this case we simply set the general attribute.
*)
\    ?class  ^comp_class ffa 1+ dup c@ 4 or  swap c!  ;

    4 into_flags  ;


\                    ===========================
\                            SELECTORS
\                    ===========================

\ First, here are the special-purpose things which can follow a selector.
\ These can't appear in isolation.

\ We allow ** and [] as synonyms of [ ] to late-bind to whatever is on the
\ stack.  Note:  [] is used in JForth.

\ We also allow [self] as a synonym of [ self ]


: ]
    hide  dfrSelID  1 = IF   postpone ]  EXIT  THEN        \ if no late bind, this is a
                                                        \  standard Forth ]
    dfrSelID NIF  187 die  THEN        \ late bound pubilc ivar reference
                                    \  not implemented yet!
    state
    IF        251 ?pairs  dfrSelID  postpone literal
            " send" evaluate        \ need PPC version of SEND
    ELSE    $ deadbeef $ 106 db        \ shouldn't happen
            dfrSelID  send
    THEN
    1 -> dfrSelID  ;        immediate


(* REFTOKEN ( -- cfa tokenType | -- various type )
   is called when we've parsed a selector - it determines the type of the
   following word.

   The order of checking determines the priority of names.  Up to 2.6 we
   checked for locals first, but this was a bad idea since a local could
   have the same name as an object, and implicit late binding to locals
   was legal.  This wouldn't show up until a crash at run time.  So now we
   check for temp objects, then ivars, then locals IF implcit_late_bind? is
   true.

   "various" will be the cfa of whatever came after the selector, or
   ( offset ^ivar ) for ivars and temp objects (which are treated as ivars
   of the class Dummy).
*)

: REFTOKEN        \ ( -- cfa tokenType | -- various type )

    false -> need_class?
    Mword                                    \ grab next word
    TOfind    IF  tmpObjTyp    EXIT  THEN        \ check for temp object
    IVfind    IF  ivarTyp        EXIT  THEN        \ check for ivar

    implicit_late_bind?
    IF    Pfind    IF  locTyp    EXIT  THEN        \ check for named parm/locals
    THEN

    ( here )  dup thread dup @ +  (find)  0=  ?error 125
    dup ['] **            =  IF  lbTyp                            EXIT  THEN
    dup ['] []            =  IF  lbTyp                            EXIT  THEN
    dup ['] [            =  IF  bktTyp                            EXIT  THEN
    dup ['] [self]        =  IF  lbSelfTyp                        EXIT  THEN
    dup ['] super>        =  IF  superTyp                            EXIT  THEN
    dup ['] ivar>        =  IF  pubIvarTyp                        EXIT  THEN
    dup ['] class_as>    =  IF  true -> need_class?  classTyp    EXIT  THEN
    dup hdlr
    CASE
        objCode        OF    >obj  objTyp    ENDOF
        classCode    OF    classTyp        ENDOF
        -90            OF    classTyp        ENDOF        \ Exported class
        objPtrCode    OF    objPtrTyp        ENDOF
        valCode        OF    valTyp            ENDOF
        wordCode    OF    wordTyp            ENDOF
        vectCode    OF    wordTyp            ENDOF
                                \ Note: here we can treat vectors as words.

        126 die                    \ "Not an object name"
    ENDCASE

\ but if we got wordTyp or valTyp, it's only legal if implicit_late_bind?
\  is true
    implicit_late_bind?  ?EXIT        \ all OK - done
    dup wordTyp =  over valTyp =  or
    IF  126 die  THEN
;



\ These words handle the binding of a selector to whatever follows it.

(*    FIX_PIVAR does the housekeeping for accessing a public ivar.  When we
    encounter  msg: ivar>  then we store the selector in pivSel, and the
    hashed ivar name in pivar.  We then continue with a zero "selector",
    which signals that it's a public ivar access, and leads to us being
    called back here to fix everything up once we've got the class.
*)

: FIX_PIVAR  { ^class in_class? \ ^ivar offs xdispl-offs -- cfa offs xdispl-offs }

    pivar ^class <findIV>            \ ( ^ivar offs xdispl-offs true  OR  false )
    0= ?error 192                    \ "ivar not found"
    -> xdispl-offs  -> offs  -> ^ivar
    ^ivar iffa w@                     \ get ivar flags
    dup 4 and 0=    ?error 193        \ ivar not public
    2 and                            \ static flag
    in_class?
    IF        0=  ?error 197            \ ivar not static
    ELSE    ?error 195                \ wrong syntax for public static ivar
    THEN

\ now we find the method in the ivar's class

    pivSel ^ivar  ivFindm drop        \ %%% don't worry about large_obj_arrays
                                    \  which are ivars yet!
  ( cfa  offs-within-ivar )
    in_class?
    IF            \ for public static ivars, the "offset" we return is
                \  actually the ivar's real data address.
        drop ^ivar  20 ( static_ivar_offs ) +  @abs  -> offs
    ELSE
        ++> offs
     THEN
     offs  xdispl-offs
;


\ PUBLIC_STATIC_IVAR_REF handles a message bind to a public static ivar
\ (done via the  msg: ivar> in_class someClass  syntax)

: PUBLIC_STATIC_IVAR_REF
    refToken
    classTyp <>  ?error 196            \ class name must follow in_class
    true  fix_pivar drop            \ %%% don't worry about large_obj_arrays
                                    \  which are public static ivars yet!
    0  bind_to_obj
;


\ OBJREF handles a reference to a normal object.

: OBJREF  { selID ^obj \ cfa offs xdispl-offs -- }

    selID
    IF    selID ^obj  objFindM
    ELSE                \ it's a public ivar reference in the referenced object
        ^obj >class  false  fix_pivar
    THEN

  ( cfa offs xdispl-offs )  -> xdispl-offs  -> offs  -> cfa

    xdispl-offs
    IF
        ^obj xdispl-offs +  lit_addr
        " dup @ +" evaluate
        offs IF                \ will normally be zero
                offs postpone literal
                " +" evaluate
            THEN
        cfa bind_to_stk  EXIT
    THEN

     cfa ^obj offs bind_to_obj
;


\ IVARREF handles a reference to an ivar.

: IVARREF  { selID ^ivar offs xdispl-offs \ cfa stat? -- }
    heldMod  0 -> heldMod                \ save
    offs  $ FFFE >=  -> selfRef?        \ if self or super.  Allows private
                                        \ methods to be found by (findm)
    selfRef?
    IF  supers_to_skip -> sups2skip        \ sups2skip is interrogated by (findm).
                                        \  This must only be done if self or
                                        \  super is the target.
        0 -> offs                        \ "real" offset is zero
    ELSE
        ^ivar iffa w@ 2 and  -> stat?    \ static ivar?
    THEN
    selID
    IF    selID ^ivar ivFindM            \ %%% don't worry about large_obj_arrays
                                    \  which are ivars yet!
        selfRef? IF -> xdispl-offs  ELSE drop THEN

        ++> offs                    \ add embedded obj base offs to ivar offs
        -> cfa
        0 -> sups2skip  0 -> supers_to_skip

        selfRef?
        IF    xdispl-offs
            IF    xdispl-offs postpone literal
                " ^base + dup @ +"  evaluate
                cfa  bind_to_stk
            ELSE
                cfa offs bind_to_self  false -> selfRef?
            THEN
            ?unholdMod  -> heldMod   EXIT
        THEN

    ELSE                \ it's a public ivar reference within the referenced ivar
        ^ivar ^iclass false  fix_pivar drop        \ %%% don't worry about large_obj_arrays
                                                \  which are ivars yet!
        ++> offs  -> cfa
    THEN

    stat?
    IF    cfa ^ivar 26  bind_to_obj
        ?unholdMod  -> heldMod  EXIT
    THEN

    xdispl-offs
    IF    xdispl-offs postpone literal
        " ^base + dup @ +"  evaluate
        offs IF                        \ will normally be zero
                offs postpone literal  " +" evaluate
            THEN
        cfa  bind_to_stk
    ELSE
        cfa offs  bind_to_ivar
    THEN
    ?unholdMod  -> heldMod
;


\ OP/CL is common code factored out of objPtrRef and classRef, which
\ are very similar.

: OP/CL  { selID ^class \ cfa offs xdispl-offs -- }
    selID
    IF    selID ^class clFindm
    ELSE
        ^class  false  fix_pivar
    THEN
    -> xdispl-offs  -> offs  -> cfa

    xdispl-offs
    IF    xdispl-offs postpone literal
        " + dup @ +"  evaluate
    THEN

    offs postpone literal  " +" evaluate
    cfa bind_to_stk
;


\ OBJPTRREF handles a reference to an object pointer.

: OBJPTRREF  { selID OP-cfa \ OPclass cfa offs xdispl-offs addr -- }
    OP-cfa  (comp)                    \ Compile a fetch of the OP-cfa,
                                    \  giving ^obj at run time
    OP-cfa 2+ @abs  -> addr
    addr 4+ @abs  -> OPclass
    OPclass  0= ?error 86            \ "ObjPtr hasn't had a class specified"
    OPclass hdlr -90 =
    IF                                \ Class is exported
        OPclass 6 + wdisplace        \ Addr of module
        compmod =  ?error 84        \ It's the module we're compiling -
                                    \  this is a no-no, since the ObjPtr
                                    \  reference will use the OLD module!
        OPclass  ?>classInMod -> OPclass
    THEN
    selID OPclass  OP/cl
;

\ CLASSREF handles a reference to a class - this means use the object
\  whose addr is on the stack, but ASSUME it is of the given class
\  and early bind, without checking.
\ The code is very similar to objPtrRef, naturally enough.

: CLASSREF { selID ^class \ cfa offs xdispl-offs -- }
    need_class? IF  '  chkClass -> ^class  false -> need_class?  THEN
    selID ^class  OP/cl
;


\ TMPOBJREF handles a reference to a temp object.

: TMPOBJREF  { selID offs ^tmpObj \ svHeldMod cfa xdispl-offs -- }
    heldMod -> svHeldMod  0 -> heldMod
    selID
    IF    selID ^tmpObj ivFindM
    ELSE
        ^tmpObj 8 + @abs  false  fix_pivar
    THEN
    -> xdispl-offs  ++> offs  -> cfa

    xdispl-offs
    IF    postpone locReg
        xdispl-offs postpone literal  postpone +
        postpone dup postpone @ postpone +
        offs IF  offs postpone literal  postpone +  THEN    \ will normally be zero
        cfa  bind_to_stk
    ELSE
         cfa offs  bind_to_tmpObj
        svHeldMod -> heldMod
    THEN
;


\ SuperRef handles the  msg: super> someSuper  construct.

: SUPERREF { selID \ ^nway namedClass ^nway' cnt -- }
    ?class                            \ Must be compiling a class
    '  -> namedClass                \ get named class xt
    ^comp_class sfa -> ^nway
    ^nway -> ^nway'  0 -> cnt
    BEGIN
        ^nway' @ 0= ?error 120            \ "superclass" not found
        ^nway' @abs namedClass =
    NWHILE
        1cell ++> ^nway'  1 ++> cnt
    REPEAT
    cnt -> supers_to_skip
    selID
    " SUPCL" sFind drop 46 +    \ careful of hard-coded number here
    $ FFFE  0  ivarRef            \ equivalent to msg: super
;


forward COMPREF

\ PubIvarRef handles the  msg: ivar> someIvar IN someObj  construct, to
\  send a message directly to a public ivar in an object.  At this point
\  we've just read "ivar>".

: PUBIVARREF  { selID \ addr len ^class ^ivar -- }
    selID -> pivSel                    \ save selID being sent to the ivar
    mword hash  -> pivar            \ parse ivar name
    mword count  -> len  -> addr
    addr len  " IN" s=
    IF    0                 \ dummy "selID" for compRef (not a legal selector)
        compRef            \ handle whatever object comes after IN.  The
                        \  zero selector signals that a public ivar in the
                        \  indicated object is to be accessed - real selectors
                        \  can't ever be zero.  This will lead to fix_pivar
                        \  being called to complete the job.
    ELSE
        addr len " IN_CLASS" s=
        IF        public_static_ivar_ref
        ELSE    true ?error 194        \ "wrong syntax for public ivar"
        THEN
    THEN
;


\ LBselfRef handles messages to [self] - i.e. late bound to Self.

: LBSELFREF  ( selID -- )
    " self" evaluate  postpone literal        \ pushes ^self, then selID
    " send" evaluate                        \ ppc send
;


\ Now here are the main words which compile the selector bindings.

\ CompRef operates at compile time - it compiles a selector bind.

:f COMPREF        \ ( selID -- )

    refToken    \ ( selID <various> type )
                \    <various> will be the cfa of whatever came after the selector,
                \    or ( offset ^ivar ) for ivars and temp objects (which are
                \    treated as ivars of the class Dummy).

    CASE
        objTyp        OF  objRef                            ENDOF
        ivarTyp        OF    ivarRef                            ENDOF
        objPtrTyp    OF  objPtrRef                        ENDOF
        tmpObjTyp    OF  tmpObjRef                        ENDOF
        classTyp    OF    classRef                        ENDOF

\ These next 3 can only come up if implicit_late_bind? is true:
\        valTyp        OF  compdfr                            ENDOF
\        locTyp        OF  compdfr                            ENDOF
\        wordTyp        OF  compdfr                            ENDOF

        lbTyp        OF  drop  postpone literal
                        " send" evaluate  ( ensure we get ppc "send" )
                                                        ENDOF
        lbSelfTyp    OF  drop  LBselfRef                    ENDOF
        bktTyp        OF  drop  -> dfrSelID  251            ENDOF
        superTyp    OF    drop  superRef                    ENDOF
        pubIvarTyp    OF    drop  pubIvarRef                ENDOF

        82 die                        \ "Selector can't be used on that"

    ENDCASE
    update_refcnts

;f


(*
RunRef is the execution mode equivalent - it executes a selector bind.
We do this simply by compiling it in a buffer then executing it there.
This replaces the earlier scheme where we had to separately handle each
case as for compRef - this was a Neon carryover.

While we're compiling in the buffer, we save the DP on the return stack,
then restore it before executing what we compiled (since it might do some
compiling itself).  This isn't long, but it's a bit tricky:
*)


: RUNREF  { selID \ svDP svBufPtr svState -- }
    DP -> svDP                \ save DP
    DP hiDP umax -> hiDP    \ so we can reset DP to right place on an error

    bufPtr NIF  runRefBuf  ELSE  bufPtr  THEN
    dup -> DP  -> svBufPtr    \ now we'll compile in runRefBuf
    state -> svState        \ save state
    postpone ]            \ need compile state so this compilation works properly
    selID compRef        \ compile the binding
    svState -> state    \ restore state
    0 -> hiDP            \ don't need it any more and could cause problems
    ?unholdMod
    DP -> bufPtr        \ new bufPtr value
    svDP -> DP            \ restore DP since the code might compile something
    patches_done        \ we're about to execute what we just compiled
    svBufPtr execute    \ execute at old bufPtr location
    svBufPtr -> bufPtr    \ then restore old bufPtr
;


\                ======== Selector support =========


\ MESSAGE is the handling word invoked by using a selector.

: MESSAGE        immediate
    state
    IF                      \ Compile state
        compRef                \ Compile the message send
        ?unHoldMod
    ELSE
        runRef                \ Run state - execute object/vector reference.
                            \ ?unHoldMod is called by ex-method at the
                            \ end, so we don't need to call it here.
    THEN  ;


\ 1stFind lumps together all the special cases we have to look for after
\ we've parsed an input word, but before we can do a regular dictionary
\ lookup.  At present these are selectors, named parms/locals, ivars
\ and local objects.  If we invent more later, they can easily be added.
\ The vector Ufind is then set to this word so it is called before the
\ regular dictionary search.  If we succeed here, we return the selector
\ ID or zero, the cfa of the handling word, and 1 or -1 (this will cause
\ FIND to exit without doing anything more).  If we fail, we return the
\ original string address and false.

: 1stFIND    \ ( str-addr -- selID message-cfa T  |  -- str-addr F )
    sel?                        \ is it a selector?
    IF        hash                \ yes - leave selID
            ['] message  1        \  and cfa of message, and 1 (it's immediate)
    ELSE    LocFind                \ no - look for the various kinds of local name
    THEN  ;


' 1stFind -> Ufind


\ : OBJLEN    \ ( -- objlen )  Computes total data length of current object.
\
\    ^base (^dlen)  dup w@  swap 2+ w@  ?dup
\    IF  idxBase 4- @ 1+  *  + 4+  THEN   ;


getSelect classinit:  -> initID


\ forward DUMP


\ SET_CLASS is a utility word used to patch nucleus objects when their classes
\ are defined in higher-level files.  Actually it could be used to change the
\ class of any object, if anyone is silly enough to want to do that.

\ Usage:  fFcb  ['] file  set_class

: SET_CLASS  { ^obj theClass -- }
    theClass  chkClass  ^obj 8 -  reloc!        \ Patch ^class
    2  ^obj  2-  w!                    \ Not indexed (yet)
    -4 ^obj  4-  w!  ;                \ ^class offset


: CHKSAME        \ ( ^obj -- ^obj )
        \ A check that two objects are of exactly the
        \ same class.
    dup >classXt  ^base >classXt  <> ?error 87  ;




\            ========= Object pointers ==========

(*    Object pointers are low-level objects (like VALUEs) which point to a
    normal (high-level) object, and which allow early-bound messages to be
    sent to the object by syntactically sending them to the object pointer.

    The normal syntax is

    ObjPtr  ZZZ    class_is  someClass

    Thereafter, any messages sent to zzz are early-bound to the object that
    zzz points to at the time the message executes.

    If you need to declare the object pointer before the class exists, use
    SET_TO_CLASS once the class is defined, thus:

    :class  SOMECLASS    super{ object }

    ' someOP  set_to_class  someClass

    etc.
*)


: (toOP)  { ^obj OPcfa \ OPclass addr -- }

    OPcfa 2+ @abs -> addr        \ note: in the PPC native version (see right
                                \  near the end), litAddr_h does this for us.

    ^obj  nilP =                \ If we're storing nil, anything goes
    check_OP_stores? not or        \ Or if checking is turned off
    NIF
        addr 4+ @abs -> OPclass
        ^obj 8 - @abs OPclass  <>
        IF                          \ Mismatch. We give some useful(?) info.
            cr  ^obj obj> .id ."  -> "  OPcfa .id
            87 die
        THEN
    THEN
    ^obj addr !
;


:f  ToObjPtr
    state
    IF  litAddr_h  " (toOP)" evaluate  ELSE  (toOP)  THEN  ;f


: CLASS_IS    \ ( --< class > )
    ?exec  '  chkClass  DP 4-  reloc!  ;


\        ===================================

\ Bytes is used as the allocation primitive for basic classes

: BYTES  { numBytes \ svRec? -- }
    ?class
    rec? -> svRec?  true -> rec?            \ Don't want an object header here
    " object" sFind drop  ivDef
    numBytes  ^comp_class dfa  w+!
    svRec? -> rec?  ;


\ Temp objects aren't needed for the code generator, so we defer them
\  to zClass, which simplifies life considerably.


(*        =================  Records and unions  ====================

Syntax:

    record <name>        \ The name is optional
   {    var        v1
        int        i1
        string    s
   }

       union <name>        \ The name is optional
   {    var        v1
        int        i1
        string    s
   }


Or you can use record{ ...  } or union{ ... } if you prefer, if it's
unnamed.  The similarity of syntax to temp objects is quite deliberate.
But any similarity to Your Favorite Language is entirely accidental.  Well
actually it's not, but I think this syntax is as good as any, and probably
more readable for folks coming from the land of C.

unions can be nested within records and vice versa.

NOTE: it's best to not use unions unless you're really sure you know what
you're doing.  Having different objects sharing the same memory is sure
to cause problems if you're careless!

*)

: SVREC
   ^comp_class dfa w@
    rec?  union?  unionOffs  68k_align?
;

: RSTREC
    -> 68k_align?  -> unionOffs  -> union?  -> rec?
    union? IF     \ we fell back in a union, so we
                \ reset data pointer to where it was at the beginning
                \ of this union/rec
        ^comp_class dfa w!
    ELSE
        drop
    THEN
;

: ?HANDLE_NAME  { \ sv_>in sv_^class sv_rec? -- }
    >in @ -> sv_>in ^comp_class -> sv_^class  rec? -> sv_rec?
    Mword  count  " {" s=
    NIF                            \ we've got a name for the record
        true -> rec?            \ must do this before defining the name "object"
        sv_>in  >in !
        " object" sFind drop  ivDef
        sv_rec? -> rec?  sv_^class -> ^comp_class
        gobble{                    \ "{" must follow
    THEN
;


: }RECORD
    131 ?pairs  rstRec
    ['] } >body !  ;


: RECORD{
    ?class                        \ must be compiling a class
    ['] } >body @                    \ save old action for "}"
    ['] }record  -> }            \ "}" will now be same as }record
    svRec                        \ save parameters for any existing record/union
    131                            \ for ?pairs
    true -> rec?  false -> union?  ;

: RECORD
    ?handle_name
    record{  ;

: 68k_RECORD{
    record{
    true -> 68k_align?  ;

: 68k_RECORD
    record
    true -> 68k_align?  ;


: }UNION
    132 ?pairs
    unionOffs  ^comp_class dfa w!
    rstRec
    ['] } >body !  ;                \ restore old action for "}"

: UNION{
    ?class                        \ must be compiling a class
    ['] } >body @                    \ save old action for "}"
    ['] }union  -> }            \ "}" will now be same as }union
    svRec                        \ save record/union parameters
    132                            \ for ?pairs
    true -> rec?  true -> union?
    ^comp_class dfa w@ -> unionOffs  ;


: UNION
    ?handle_name
    union{  ;


\ This is for finding a bug:

: TCHK  { thread# \ thread_addr lfa -- }

    thread# dummy_len c!                \ fake a "length byte" for THREAD
    dummy_len thread  -> thread_addr    \ addr of thread start in CONTEXT

    thread_addr displace  -> lfa        \ addr of first link field in thread,
                                        \  in CONTEXT
    BEGIN
        ?pause
        lfa displace                    \ chain back
        dup code_start u<
        IF    drop        \ next link field is below start of code
            EXIT
        THEN
        ." lfa: " lfa .h 3 spaces  lfa link> .id  cr
        -> lfa
    AGAIN
;

endload

[THEN]        \ ppc? not [if]

(*    Thus before CROSS, the first time through, we stop there.
    We now define OBJECT and optionally the torture tests, in target
    compilation mode.
*)


\        ===================================

forward dump

forward    I/O_ERR        \ ( err# -- )  Call when there's an I/O error.

: OK?        \ ( rc -- )  A useful word to use after an I/O op.
    ?dup  0EXIT  I/O_err  ;

variable    self_vbl

define_meta

^self  self_vbl  displ!x




: CAN_BE_GPR        $ 30  into_flags  ;
: CAN_BE_FPR        $ 40  into_flags  ;
: CAN_BE_VR            $ 50  into_flags  ;

: ALIGNMENT  ( n -- )  8 << into_flags  ;        \ n is power of 2



:class    OBJECT    super{ meta }

:m CLASS:    ^base ?>class ( ?>classinMod )  ;m

:m GETNAME:    ( -- addr len )
    ^base obj>
    ?dup IF  >name n>count  ELSE  " <no name>"  THEN  ;m

:m .ID:        getName: self  type  ;m

:m .CLASS:    ^base >classXt  .id  ;m

:m ADDR:    inline{ ^base}  ;m

\ :m ABS:        ^base  ;m        \ now obsolete

:m LENGTH:    \ ( -- len )  Gets total length of object.
    objlen  ;m

:m #ELEMENTS:  ( -- #elems )
    ^base (^dlen)  2+ w@        \ indexed width
    IF            \ we're indexed
        idxBase 4- @ 1+
    ELSE        \ not indexed - return -1
        -1
    THEN
;m


(*    Here are two methods which operate between this object and another of
    the same class.  Note we don't check that the passed-in object is actually
    of the same class, since it could be a subclass but still be safe to use
    here.
*)

:m COPYTO:    \ ( ^obj -- )  Copies the ivar part of the passed-in object
            \ to self.
    ^base  dup (^dlen) w@  aligned_move  ;m

:m =?:        \ ( ^obj -- b )  Returns true if the ivar part of the passed-in
            \ object is identical to self.
    ^base  dup (^dlen) w@  (s=)  ;m


(*    The following methods need to be defined for all objects.
    We give them their default definitions here.
*)

:m CLASSINIT:  ;m    \ Our standard constructor method.  Called automatically
                    \ whenever an object is created.

:m DEEP_CLASSINIT:    \ Also does classinit: on all nested ivars.  Use for
                    \  totally (re-)initializing an object.
    classinit: [ self ]        \ ivsetup doesn't do this, so we do it explicitly
    (^base) -> newObject
    class: self ifa displace  0  0
    ivSetup
;m


(*    RELEASE: is our standard destructor method.  Any objects that
    allocate heap storage will redefine this appropriately.
    Our rule is that an object will release ALL its    storage
    when it gets a release: message. Other methods can be
    provided to partly release storage, as needed.
*)

:m RELEASE:    inline{ }  ;m


(*    SEND: and BRING: handle serialization of an object, so
    it can be saved to a file or whatever.  We take a
    passed-in object as the source/sink for the serialized
    bytes.  It can be any object that supports the stream
    methods read: and write:.

    Here in class Object we just assume we can just write
    the object's local data.  Any classes that use handles
    etc. will have to do a bit more than this.

    We write the non-indexed and indexed data separately,
    to meke these operations less sensitive to platform-related
    alignment questions.  On the PPC the indexed area
    starts out 4-byte aligned, but only 2-byte aligned
    on the 68k.  Of course alignment issues within the
    local ivars might rule out cross-platform compatibility
    anyway, but there will be many situations in which
    what we do here will work.
*)

:m SEND:  { stream \ ^dlen xwid -- }

    ^base (^dlen)  -> ^dlen
    ^base
    ^dlen w@                        \ ivar len
    write: [ stream ]  OK?            \ write out ivar data

    ^dlen 2+ w@  dup -> xwid  0EXIT    \ if not indexed, we're done

    idxBase dup
    4- @ 1+  xwid *                 \ indexed length
    write: [ stream ]  OK?            \ write out indexed data
;m

:m BRING:  { stream \ ^dlen xwid -- }
    ^base (^dlen)  -> ^dlen
    ^base
    ^dlen w@                        \ ivar len
    read: [ stream ]  OK?            \ read ivar data

    ^dlen 2+ w@  dup -> xwid  0EXIT    \ if not indexed, we're done

    idxBase dup
    4- @ 1+  xwid *                 \ indexed length
    read: [ stream ]  OK?            \ read indexed data
;m


:m DUMP:
    .id: self  ."  class: "  .class: self
    ^base objlen  dump  ;m


:m PRINT:        \ Used for a formatted display, if appropriate.
                \ Default is just a dump.
    dump: self  ;m


;class


(* ***********

\ A simple test of the basic class stuff - run if the plot
\  gets totally lost:


:class testClass super{ object }
:m aa: 1 2 3 ;m
:m bb: 99 aa: self  ;m
;class


:class cl2 super{ testClass }
  testClass bloggs
:m cc:  $ 1234  bb: bloggs
;m
;class


cl2  myObj

********** *)


\            ========= Object pointers ==========

\ Here we just need the PPC native version of (toOP).


true    value    check_OP_stores?    \ allows us to turn off type checking
                                    \  for stores to objPtrs

: (toOP)  { ^obj addr \ OPclass -- }
    \ addr is the obj ptr info in the data area, courtesy of litAddr_h
    \ (if compiling) or >body (if interpreting).  See ToObjPtr in
    \  zClass.

    ^obj  nilP =                \ If we're storing nil, anything goes
    check_OP_stores? not or        \ Or if checking is turned off
    NIF
        addr 4+ @abs -> OPclass
        ^obj 8 - @abs OPclass  <>
        IF                          \ Mismatch. We give some useful(?) info.
            cr  ^obj obj> .id
            87 die
        THEN
    THEN
    ^obj addr !  ;


endload

+echox

\ ===============================================================
\                        TORTURE TESTS
\ ===============================================================

\ This is a slightly cut-back version of the full torture tests
\  as in zClass.  A few things aren't implemented in the target
\  compilation since the code generator doesn't use them.


: ?CHK
    2dup <>
    IF    cr .h cr .h
        true abort" check FAILED!!!"        \ error if something doesn't
                                            \  give what we expect
    ELSE
        2drop
    THEN
;

: leaf  ;

:class    VAR    super{ object }

    4 bytes data

:m CLEAR:
    inline{ 0 ^base !}  ;m

:m GET:
    inline{ ^base @}  ;m

:m PUT:
    inline{ ^base !}  ;m

:m GETT:    ^base @  ;m

:m PUTT:    ^base !  ;m

:m +:
    inline{ ^base +!}  ;m

:m -:
    inline{ ^base -!}  ;m

:m ->:
    inline{ @ ^base !}  ;m

:m TEST:  @ ^base !  ;m

mlocal LOCTEST:  { aa \ bb cc -- }

:m AAA:    aa -> bb ;m

:mloc  LOCTEST:
    aaa: self aaa: self aaa: self cc -> bb  ;mloc


:m PRINT:
    ^base @  .  ;m

:m CLASSINIT:
    $ 123  put: self  ;m

;class


:class    BYTE    super{ object }

    1 bytes data

:m CLEAR:
    inline{ 0 ^base c!}  ;m

:m GET:
    inline{ ^base c@x}  ;m

:m UGET:
    inline{ ^base c@}  ;m

:m PUT:
    inline{ ^base c!}  ;m

:m ->:
    inline{ c@ ^base c!}  ;m

:m PRINT:
    ^base c@  .        ;m

:m CLASSINIT:    9 put: self  ;m

;class

\ +echox

\ some very simple testing, to start with:

0        value    testVal
        var        aVar
        byte    aByte

: test1
." test1" cr
    987 avar !  get: avar  987 ?chk            \ optimizes
    addr: avar  -> testVal
    876 testVal !                            \ should clobber opt
    get: avar  876  ?chk
;

: test2            \ testing late binding - assumes test1 done
." test2" cr
    get: [ avar ]  876  ?chk
;


var vv


:class    BOOL    super{ byte }

:m GET:
    inline{ ^base c@x}  ;m

:m PUT:
    inline{ 0<> ^base c!}  ;m

:m SET:
    inline{ true ^base c!}  ;m

:m PRINT:
    get: self  IF  ." true"  ELSE  ." false"  THEN  ;m

:m CLASSINIT:    clear: self  ;m

;class


:class    BARRAY  super{ object }  1 indexed

:m  AT:        \ ( index -- n )
    inline{ ^elem c@}  ;m

:m  TO:        \ ( n index -- )
    inline{ ^elem c!}  ;m


:m ^ELEM:    \ ( index -- addr )
    inline{ ^elem}  ;m

:m FILL:    \ ( value -- )  Fills all elements with value.
    idxbase  limit 2*  bounds
    ?DO  dup  i c!  LOOP  drop  ;m

:m WIDTH:    1  ;m        \ Faster than the default in Object

:m GETELEM:    \ ( addr -- n )  Fetches one element at addr
    c@x  ;m

:m TEST:    at: self  ;m

;class


\ Testing arrays:

20 barray bb

: test3
." test3" cr
    $ 9887 bb 20 + c!
    12 -> testVal
    testVal test: bb  $ 87 ?chk
    120 -> testVal
\ ." should fail range check and trap - just step past the tw:" cr cr
\    testVal test: bb            \ should fail range check
;

\ also we test indexed classes which are subclassed and have
\  added ivars, to make sure we get the right offset to the
\  indexed header:

:class    INDEXED-OBJ  super{ object }

:m ^ELEM:    ^elem  ;m

:m LIMIT:    limit  ;m

:m WIDTH:    idxbase  6 -  w@  ;m

:m IXADDR:    idxbase  ;m

:m CLEARX:    \ Erases indexed area.
    idxbase  limit  width: self  *  erase  ;m

:m CLASSINIT:    clearX: self  ;m

;class


:class    WARRAY  super{ indexed-obj }  2 indexed

:m AT:        \ ( index -- n )
    inline{ ^elem w@x}  ;m

:m ATT:        ^elem w@x  ;m

:m TO:        \ ( n index -- )
    inline{ ^elem w!}  ;m

;class


:class  TRIGTABLE    super{ wArray }

    3    wArray  AXISVALS
;class

10 trigtable ttt
$ 56  ttt $ 26 + w!

: test4 { \ xx -- }
    ." test4" cr
    addr: ttt  -> xx        \ so we can look at it in the debugger
    3 at: ttt  $ 56 ?chk  ;


\ Testing object pointers

var        vv1

objPtr    ov    class_is var
objPtr    ov1    class_is var

objPtr    ob    class_is bool


: test5
    ." test5" cr
    $ 765 put: vv  $ 543 put: vv1
    vv1 -> ov1  vv -> ov
    gett: ov1  $ 543  ?chk  get: ov  $ 765 ?chk
    $ 345 putt: ov  get: ov  $ 345 ?chk  ;



\ static ivar check omitted - not needed for code generator so not
\  implemented in target compilation



\ Testing late bind to self

:class VAR+ super{ var }

:m QQ:    get: [self]        \ should make class general
        get: [ self ]    \ shouldn't give any error
;m

;class

var+ VVV

\ qq: vvv        \ no need for ?chk since it will give its own error

: test8
    ." test8" cr
    qq: vvv  2drop
;


\ Testing records and unions.  Also, the TEST: method piles up so many
\  values that this also tests register spilling with a duplicate value!

:class RECTEST super{ object }
    var    vv
    record RR
    {        var        v1
            bool    b1
        3    barray  bbb
            byte    b3            \ now aligned - unions should normally
                                \  start out aligned, but we don't insist
                                \  on it
        union {    byte    b2
                var        v2
                record    {    byte bb1
                            byte bb2    }
            }
            var        v3
    }

:m TEST:
    4 0 to: bbb  5 1 to: bbb  6 2 to: bbb
    $ 33  put: vv
    $ 123 put: v1  set: b1  $ 124 put: v2  7 put: b3
    $ 35 put: bb1  $ 36 put: bb2  $ 125 put: v3  $ 37 put: b2
    get: v1  put: b1
    get: b2  get: v2  get: bb1  get: bb2  get: v3
    addr: rr  36 + @
;m
;class

recTest rrr

: test9
    ." test9" cr
    $ 33  addr: vvv !
    qq: vvv
    $ 33        ?chk
    $ 33        ?chk
    test: rrr
    $ 125        ?chk
    $ 125        ?chk
    $ 36        ?chk
    $ 37        ?chk
    $ 37360124    ?chk
    $ 37        ?chk
    rrr $ 2C + @  $ 04050607  ?chk
;


\ testing multiple inheritance

:class INT  super{ object }

    2    bytes    data

:m CLEAR:
    inline{ 0 ^base ! }  ;m

:m UGET:
    inline{ ^base w@ }  ;m

:m GET:
    inline{ ^base w@x }  ;m

:m PUT:
    inline{ obj w! }  ;m

:m PUTT:    ^base w!  ;m
:m IPUT:    ^base w!  ;m        \ used in testing mult inheritance

:m CLASSINIT:  $ 456 put: self  ;m

;class


:class CC  super{ byte int var bool }

:m TEST:
iput: self    \ check it compiles
    uget: self            \ offs should be 0
    +: self                \ offs should be 4
    set: self  ;m        \ offs should be E

:m TEST1:
    set: self
    get: super> bool    \ should get -1
    get: super
;m

:m setValues:
    9 put: super> byte
    $ 456  putt: super        \ should go to the int
    $ 456  put: super> int
    $ 123  put: super> var
    set: super
;m

;class

cc myCC

: test10 { \ addr -- }
    ." test10" cr
    addr: mycc -> addr
    setValues: mycc
    mycc @        $ 09000000    ?chk
    mycc 4+   @    $ fff40002  ?chk
    mycc 8 +  @    $ 04560000    ?chk
    mycc 12 + @ $ ffec0002  ?chk
    mycc 16 + @    $ 123        ?chk
    mycc 20 + @ $ ffe40002  ?chk
    mycc 24 + @ $ ff000000  ?chk
;


:class STRANGE  super{ object }
    var VV
    byte BB
:m GET:  get: vv  get: bb  ;m
:m PUT:  put: bb  put: vv  ;m

;class


:class    ARRAY  super{ indexed-obj }  4 indexed

:m AT:        \ ( index -- n )
    inline{ ^elem @}  ;m

:m ATT:        ^elem @  ;m

:m TO:        \ ( n index -- )
    inline{ ^elem !}  ;m

:m  +TO:        \ ( n index -- )
    inline{ ^elem +!}  ;m

:m -TO:        \ ( n index -- )
    inline{ ^elem -!}  ;m

:m FILL:        \ ( value -- )  Fills all elements with value.
    idxbase  limit 4*  bounds
    DO  dup  i !  4 +LOOP  drop  ;m


:m ATEST:
    1 at: self  ;m

;class


:class MULT    super{ var int array }

:m MTEST:    $ 456  put: super> int  $ 123  put: super> var
            uget: super  999 1 to: self  ;m

:m MAT:        at: self  ;m

;class


objPtr    OO    class_is mult
objPtr    OOO    class_is int

:class IVXX    super{ object }
    10 bytes data2
    int    i1
    int    i2
    130 bytes qqqq        \ Include to check >128 distance
                        \  index addressing of array qwert
    9 array qwert

:m ITEST:
    $ 8456 dup  i1 w!  addr: i2 w!        \ should be equivalent
    get: i1  uget: i2  66 put: i2
    99 3 to: qwert  1234 drop  3 at: qwert
    addr: i2  -> ooo  ;m

:m GETQWERT:
    addr: qwert  ;m
;class

int ii
3 mult    mm
ivxx    iv

: test11
    ." test11" cr
    itest: iv
    $ 63    ?chk
    $ 8456    ?chk
    $ ffff8456    ?chk
    mtest: mm
    $ 456    ?chk
    88 iput: mm        \ Note: get: mm will bind to the var, but uget: mm
                    \ will bind to the int and give 88.

    get: mm  $ 123    ?chk
    uget: mm 88        ?chk
;


: test12
." test12" cr
    itest: iv
    getqwert: iv  3 swap at: **        99    ?chk
    mtest: mm            $ 456    ?chk
    1 at: mm            999 ?chk
    1 mat: mm            999 ?chk
    1 mm at: mult        999 ?chk
    1 mm at: []            999 ?chk
    mm -> oo
    1 at: oo            999     ?chk
    1 mat: oo            999     ?chk
    uget: mm            $ 456    ?chk
    addr: mm  addr: oo            ?chk  \ Both numbers shd be same
    uget: ooo            66        ?chk
;


\ testing ivSetup (via deep_classinit: ) - this should put the $123 and
\  $456 in the var and the int, and store the same offsets in the header
\  that are already there.

:class ivsTestClass  super{ var int array }
    record
    {    var        v1
        int        i1
        byte    b1
     3     array    a1
    }
;class

5 ivsTestClass  ivs1

: test13
." test13" cr
    deep_classinit: ivs1
    addr: ivs1 @        $ 123          ?chk
    addr: ivs1 4 + @    $ FFF4003A    ?chk
    addr: ivs1 8 + @    $ 04560000    ?chk
    addr: ivs1 12 + @    $ FFEC0032    ?chk
    addr: ivs1 16 + @    $ 123        ?chk
    addr: ivs1 20 + @    $ 04560900    ?chk
    addr: ivs1 24 + @    $ 0            ?chk    \ array has no name so zero here
    addr: ivs1 28 + c@    $ 08        ?chk    \ rest of reloc addr can change
    addr: ivs1 32 + @    $ FFFC000A    ?chk
    addr: ivs1 36 + @    $ 4            ?chk
     addr: ivs1 40 + @    $ 2            ?chk
 ;


\ Temp object check omitted - not needed for code generator so not
\  implemented in target compilation



\ =========== TORTURE runs the test! ============

: TORTURE
    ." torture tests start..." cr cr
    test1 test2 test3 test4 test5
    test8 test9
    test10 test11 test12 test13
    cr cr ." torture tests WORKED!!!" cr
;




\ =========== the current test block ============


:f run
    cr cr ." Hi there." cr
    ." Type a number to start the tests." cr  1 2 3

    begin
        query cr
        begin
            rest nip 0>
        while
            defined?
            if        execute
            else
                    number
                    torture
            then
        repeat
        .s cr
    again
;f

:f quit  run  ;f        \ temp so we can catch errors!

\ marker m__pStruct
\ endload

\ ================ end of test block =================